unit vdbg;

{$mode delphi}

interface

{$region 'uses'}
uses
  Classes,
  SysUtils,
  SyncObjs,
  LCLProc,

  BaseDebugManager,
  Debugger,
  FpDbgInfo,

  vdbg.common,
  vdbg.dbgapi,
  vdbg.dbginfo,
  {$ifdef windows}
  vdbg.win;
  {$else}
    {$fatal 'it is windows-only'}
  {$endif}
{$endregion}

{ $DEFINE DEBUGLN_DEBUGEVENT_LOOP}

const
  StopOnInitialBreakpoint = False;

type

  THandledStatus = (
    hs_continue,
    hs_wait_for_user
  );

  TVDbg = class;

  { TVDebuggerThread }

  TVDebuggerThread = class(TThread)
  private
    type
      TUserCommand = (ucNone, ucTerminate, ucDetach, ucPause);
    var
      FUserCommand: TUserCommand;
  private
    FProcessIdToAttach: TVDbgProcessId;
    FProcessFileName: string;
    FProcessArguments: string;
    FHandledStatus: THandledStatus;
    procedure ThreadTerminateProc(Sender: TObject);

    // Let IDE switch to Paused state.
    procedure SyncPaused;
    procedure SyncResumed;

    // Must set FHandledStatus and FIsEventHandled.
    procedure HandleDebugEvent;

    // Must set FHandledStatus and FIsEventHandled.
    procedure HandleExceptionEvent(const Evt: TVDbgExceptionInfo);

    // Must set FHandledStatus and FIsEventHandled.
    procedure HandleBreakpoint;
  private
    FBreakpointsToReinstall: TList;
    procedure InstallBreakpoint(bp: TDBGBreakPoint);
    procedure InstallBreakpoints;
    procedure ReInstallBreakpoints;
  protected
    FDbg: TVDbg;
    FApi: TVDbgApi;
    FDbgStartupDone: TEvent;
    FContinueEvent: TEvent;
    FDebuggerInitialized: boolean;
    FIsEventHandled: boolean;
    FDbgInfo: TVDbgInfo;
    procedure Execute; override;
  private
    procedure DebuggingFinished;
    procedure DebuggerUnpaused;
  public
    constructor CreateBase(const ADbg: TVDbg);

    constructor CreateForNewProcess(
      const ADbg: TVDbg;
      const AFileName: string;
      const AArguments: string);

    constructor CreateForAttach(
      const ADbg: TVDbg;
            AProcessId: TVDbgProcessId);

    destructor Destroy; override;

    procedure SetUserCommand(ACommand: TUserCommand);
  end;

  { TVDbgLineInfo }

  TVDbgLineInfo = class(TDBGLineInfo)
   public
    procedure Request(const ASource: String); override;
  end;

  { TVDbg }

  TVDbg = class(TDebugger)
  private
    FDbgThread: TVDebuggerThread;
    procedure LogBreakpoints;
  protected
    class function GetDbgApiClass: TVDbgApiClass;

    // Let debugger know what commands we can handle.
    function GetSupportedCommands: TDBGCommands; override;

    // Handle requested commands.
    function RequestCommand(
      const ACommand: TDBGCommand;
      const AParams: array of const): Boolean; override;

    function DoEvaluate(
      const AExpression: String;
      var AResult: String;
      out ATypeInfo: TDBGType;
      EvalFlags: TDBGEvaluateFlags): Boolean;
  public
    // Return debugger caption.
    class function Caption: String; override;

    function CreateLineInfo: TDBGLineInfo; override;
    function CreateBreakPoints: TDBGBreakPoints; override;
  end;

implementation

{ TVDbgLineInfo }

procedure TVDbgLineInfo.Request(const ASource: String);
begin
  inherited Request(ASource);
  DebugLn('TVDbgLineInfo.Request: ' + ASource);
end;

{ TVDebuggerThread }

procedure TVDebuggerThread.HandleDebugEvent;
var
  BaseAddr: TVDbgAddr;
  FileName: string;
begin
  // By default, let debuggee continue handled.
  // For example if we pass it as unhandled dbgevt_output_string will be
  // triggered twice (1st and last chance).
  //
  // dbgevt_exception and dbgevt_breakpoint breakpoint must update handled
  // status separately.
  FHandledStatus := hs_continue;
  FIsEventHandled := True;

  case FApi.Event.&Type of
    { Process }
    dbgevt_process_create:
      begin
        FDbg.DoDbgEvent(ecProcess, etProcessStart, 'Process Start');
        InstallBreakpoints;
      end;
    dbgevt_process_exit:
      begin
        FDbg.DoDbgEvent(ecProcess, etProcessExit,
          Format('Process Exit. Code: %d', [FApi.Event.ProcessExit.ExitCode]));
        Terminate;
      end;
    { Thread }
    dbgevt_thread_create:
      FDbg.DoDbgEvent(ecThread, etThreadStart,
        Format('Thread Start. Thread ID: %d', [FApi.Event.ThreadId]));
    dbgevt_thread_exit:
      FDbg.DoDbgEvent(ecThread, etThreadExit,
        Format('Thread Exit. Exit code: %d', [FApi.Event.ThreadExit.ExitCode]));
    { Module }
    dbgevt_module_load:
      begin
        BaseAddr := FApi.Event.ModuleLoad.Base;
        FileName := FApi.LoadedModuleFilename;
        FDbg.DoDbgEvent(ecModule, etModuleLoad, Format('Module Load. Base: %x. "%s"', [
          BaseAddr, FileName]));
      end;
    dbgevt_module_unload:
      begin
        BaseAddr := FApi.Event.ModuleUnload.Base;
        FileName := '';
        FDbg.DoDbgEvent(ecModule, etModuleUnload, Format('Module Unload. Base: %x. "%s"', [
          BaseAddr, FileName]));
      end;
    { Output }
    dbgevt_output_string:
      begin
        if FApi.DebugOutputString <> '' then
          FDbg.DoDbgEvent(ecOutput, etOutputDebugString, Format('Debug Output: %s', [FApi.DebugOutputString]));
      end;
    { Exception }
    dbgevt_exception:
      HandleExceptionEvent(FApi.Event.Exception);
    { Breakpoint }
    dbgevt_breakpoint:
      HandleBreakpoint;
    else
      DebugLn('[vdbg] unknown debug event');
  end;
end;

procedure TVDebuggerThread.HandleExceptionEvent(const Evt: TVDbgExceptionInfo);
var
  Loc: TDBGLocationRec;
  CanContinue: Boolean;
begin
  FIsEventHandled := False;

  // todo: fill location
  Loc.Address := Evt.Address;

  DebugLn('Exception %x at %x', [Evt.Code, Evt.Address]);
  FDbg.DoException(
    deExternal, // AExceptionType
    '', // AExceptionClass
    Loc,
    '', // AExceptionText
    CanContinue// AContinue
    );

  if CanContinue then
  begin
    FHandledStatus := hs_continue;
    Exit;
  end;

  DebugLn('Pause caused by exception');

  // User can either stop process or resume on its own risk.
  FHandledStatus := hs_wait_for_user;
end;

procedure TVDebuggerThread.HandleBreakpoint;
var
  BpStr, Text: String;
  BpInfo: ^TVDbgBreakpointInfo;
  Bp: TDBGBreakPoint;
  i: integer;
  Location: TDBGLocationRec;
  pCtx: PVDbgThreadContext;
  bCtxChanged: Boolean;
  Sym: TDbgSymbol;
begin
  FIsEventHandled := True;

  BpInfo := @FApi.Event.Breakpoint;

  if BpInfo^.Initial then
    BpStr := 'Initial breakpoint'
  else
    BpStr := 'Breakpoint';

  DebugLn('--------------------------------------');
  Text := Format('%s at %x', [BpStr, BpInfo^.Address]);
  DebugLn(Text);

  if (BpInfo^.Initial) and (not StopOnInitialBreakpoint) then
  begin
    // Skip initial breakpoint.
    DebugLn('Initial breakpoint skipped.');
    // Don't need to wait user.
    FHandledStatus := hs_continue;
    Exit;
  end;

  // FDbg.DoDbgEvent(ecOutput, etOutputDebugString, Text);

  // Search breakpoint by address.
  Bp := nil;

  // This doesn't work somehow?
  //Bp := FDbg.BreakPoints.Find(BpInfo^.Address);

  // Search manually.
  for i := 0 to FDbg.BreakPoints.Count - 1 do
    if FDbg.BreakPoints[i].Address = BpInfo^.Address then
    begin
      Bp := FDbg.BreakPoints[i];
      break;
    end;

  // Try to find breakpoint location.
  if Assigned(Bp) then
  begin
    // If it's ours breakpoint.
    DebugLn('[vdbg] breakpoint found by address');
    Location.Address := Bp.Address;
    Location.SrcFile := Bp.Source;
    Location.SrcLine := Bp.Line;
    FDbg.DoCurrent(Location);
  end
  else
  begin
    // Not ours breakpoint.
    Sym := FDbgInfo.FindSymbol(BpInfo^.Address);
    if Assigned(Sym) then
    begin
      Location.Address := BpInfo^.Address;
      Location.SrcFile := Sym.FileName;
      Location.SrcLine := Sym.Line;
      DebugLn('[vdbg] non-ide breakpoint: %x "%s" line: %d', [BpInfo^.Address, Sym.FileName, Sym.Line]);
      Sym.ReleaseReference;
      FDbg.DoCurrent(Location);
    end;
  end;

  if Assigned(Bp) then
  begin
    pCtx := FApi.GetThreadContext;
    if Assigned(pCtx) then
    begin
      DebugLn('[vdbg] ip = %x', [pCtx^.GetIp]);

      // Restore original code at breakpoint address.
      FApi.DelBreakpoint(Bp.Address);

      FBreakpointsToReinstall.Add(Bp);

      // Set address at breakpoint start.
      pCtx^.SetIP(Bp.Address);

      bCtxChanged := FApi.SetThreadContext(pCtx);
      DebugLn('[vdbg] context changed: %s', [BoolToStr(bCtxChanged, True)]);
    end
    else
      DebugLn('[vdbg] GetThreadContext failed');
  end
  else
  begin
    DebugLn('[vdbg] breakpoint not found by address');
  end;

  DebugLn('Pause caused by breakpoint');

  // Wait for user to stop or resume.
  FHandledStatus := hs_wait_for_user;
end;

procedure TVDebuggerThread.InstallBreakpoint(bp: TDBGBreakPoint);
var
  srcFilename: string;
  srcLine: integer;
  addr: TDBGPtr;
  Info: TVDbgBreakpointInfo;
  bInstalled: Boolean;
begin
  srcFilename := bp.Source;
  srcLine := bp.Line;
  addr := FDbgInfo.GetLineAddress(srcFilename, srcLine);
  if addr <> 0 then
  begin
    Info.Address := addr;
    bInstalled := FApi.SetBreakpoint(Info);
    if bInstalled then
    begin
      bp.Address := addr;
    end;
  end;
  DebugLn('[vdbg] %s,%d: addr:%x installed:%s', [srcFilename, srcLine, addr, BoolToStr(bInstalled,True)]);
end;

procedure TVDebuggerThread.InstallBreakpoints;
var
  i: Integer;
begin
  DebugLn('-------------------------------------');
  DebugLn('[vdbg] InstallBreakpoints (count: %d)', [FDbg.BreakPoints.Count]);
  for i := 0 to FDbg.BreakPoints.Count - 1 do
    InstallBreakpoint(FDbg.BreakPoints[i]);
  DebugLn('-------------------------------------');
end;

procedure TVDebuggerThread.ReInstallBreakpoints;
var
  i: integer;
begin
  if FBreakpointsToReinstall.Count <> 0 then
  begin
    for i := 0 to FBreakpointsToReinstall.Count - 1 do
      InstallBreakpoint(FBreakpointsToReinstall[i]);
    FBreakpointsToReinstall.Clear;
  end;
end;

procedure TVDebuggerThread.Execute;

  function StartUp: boolean;
  begin
    if FProcessIdToAttach <> 0 then
      Result := FApi.AttachToProcess(FProcessIdToAttach)
    else if FProcessFileName <> '' then
      Result := FApi.CreateProcess(FProcessFileName, FProcessArguments)
    else
      Result := False;
  end;

  // Terminate process and skip all events until exit process event reached.
  procedure Shutdown;
  begin
    DebugLn('[vdbg] Termination. Begin');
    FApi.TerminateProcess();
    while True do
    begin
      DebugLn('[vdbg] Termination. WaitForDebugEvent');
      if not FApi.WaitForDebugEvent(-1) then
         break;
      DebugLn('[vdbg] Termination. ContinueEvent');
      if not FApi.ContinueEvent(FApi.Event.ThreadId, True) then
         break;
      DebugLn('[vdbg] Termination. Check for process exit');
      if FApi.Event.&Type = dbgevt_process_exit then
         break;
    end;
    DebugLn('[vdbg] Termination. End');
  end;

const
  WAIT_EVENT_TIMEOUT = 1000;
var
  Cmd: TUserCommand;
begin
  FDebuggerInitialized := StartUp();
  DebugLn('FDebuggerInitialized: %s', [BoolToStr(FDebuggerInitialized, True)]);
  FDbgStartupDone.SetEvent;
  FContinueEvent.WaitFor(INFINITE);

  while (not Terminated) do
  begin
    // Copy command.
    Cmd := FUserCommand;
    FUserCommand := ucNone;

    case Cmd of
      ucTerminate:
        begin
          Shutdown;
          Break;
        end;
      ucPause:
        FApi.DebugBreak();
      ucDetach:
        if FApi.Detach then
          break;
    end;

    // todo: Breakpoints must be reinstalled when leaving current breakpoint.
    ReInstallBreakpoints;

    {$IFDEF DEBUGLN_DEBUGEVENT_LOOP}
    DebugLn('WaitForDebugEvent');
    {$ENDIF}
    if FApi.WaitForDebugEvent(WAIT_EVENT_TIMEOUT) then
    begin
      case FApi.Event.&Type of
        dbgevt_process_create:
          FDbgInfo.AddSymbolsFromFile(FApi.DebuggeeFileName);
      end;

      {$IFDEF DEBUGLN_DEBUGEVENT_LOOP}
      DebugLn('HandleDebugEvent');
      {$ENDIF}
      Synchronize(HandleDebugEvent);

      case FHandledStatus of
        hs_continue:
          begin
            {$IFDEF DEBUGLN_DEBUGEVENT_LOOP}
            DebugLn('[vdbg] hs_continue');
            {$ENDIF}
          end;
        hs_wait_for_user:
          begin
            {$IFDEF DEBUGLN_DEBUGEVENT_LOOP}
            DebugLn('[vdbg] hs_pause');
            {$ENDIF}
            Synchronize(SyncPaused); // switch ide to paused state
            FContinueEvent.WaitFor(INFINITE);
            Synchronize(SyncResumed); // switch ide to running state
          end;
      end;

      {$IFDEF DEBUGLN_DEBUGEVENT_LOOP}
      DebugLn('Continue (handled: %s)', [BoolToStr(FIsEventHandled, True)]);
      {$ENDIF}
      FApi.ContinueEvent(FApi.Event.ThreadId, FIsEventHandled);
    end;

  end;

  Synchronize(DebuggingFinished);
end;

procedure TVDebuggerThread.DebuggingFinished;
begin
  FDbg.SetState(dsStop);
end;

procedure TVDebuggerThread.DebuggerUnpaused;
begin
  FDbg.SetState(dsRun);
end;

procedure TVDebuggerThread.ThreadTerminateProc(Sender: TObject);
begin
  DebugLn('[vdbg] TVDebuggerThread OnTerminate called');
end;

procedure TVDebuggerThread.SyncPaused;
begin
  FDbg.SetState(dsPause);
end;

procedure TVDebuggerThread.SyncResumed;
begin
  FDbg.SetState(dsRun);
end;

constructor TVDebuggerThread.CreateBase(const ADbg: TVDbg);
begin
  inherited Create(True);

  FreeOnTerminate := True;
  OnTerminate := ThreadTerminateProc;

  FBreakpointsToReinstall := TList.Create;

  FDbgStartupDone := TEvent.Create(nil, False, False, ''); // auto-reset
  FContinueEvent := TEvent.Create(nil, False, False, ''); // auto-reset
  FDbgInfo := TVDbgInfo.Create;

  FDbg := ADbg;
  FApi := ADbg.GetDbgApiClass.Create;
  DebugLn('[TVDebuggerThread.CreateBase] FApi created.');
end;

constructor TVDebuggerThread.CreateForNewProcess(const ADbg: TVDbg;
  const AFileName: string; const AArguments: string);
begin
  CreateBase(ADbg);
  // todo: is it thread-safe?
  FProcessFileName := AFileName;
  FProcessArguments := AArguments;
end;

constructor TVDebuggerThread.CreateForAttach(const ADbg: TVDbg;
  AProcessId: TVDbgProcessId);
begin
  CreateBase(ADbg);
  FProcessIdToAttach := AProcessId;
end;

destructor TVDebuggerThread.Destroy;
begin
  DebugLn('[vdbg] TVDebuggerThread.Destroy called');
  FApi.Free;
  FDbgStartupDone.Free;
  FContinueEvent.Free;
  FDbgInfo.Free;
  FBreakpointsToReinstall.Free;
  inherited Destroy;
end;

procedure TVDebuggerThread.SetUserCommand(ACommand: TUserCommand);
begin
  FUserCommand := ACommand;
end;

{ TVDbg }

class function TVDbg.Caption: String;
begin
  Result := '[vdbg] Simple Windows-only debugger';
end;

function TVDbg.CreateLineInfo: TDBGLineInfo;
begin
  Result := inherited CreateLineInfo;
end;

function TVDbg.CreateBreakPoints: TDBGBreakPoints;
begin
  DebugLn('TVDbg.CreateBreakPoints');
  Result := inherited CreateBreakPoints;
end;

procedure TVDbg.LogBreakpoints;
var
  i: Integer;
  bp: TDBGBreakPoint;
begin
  DebugLn('[vdbg] breakpoint count: %d', [BreakPoints.Count]);
  for i := 0 to BreakPoints.Count - 1 do
  begin
    bp := BreakPoints[i];
    DebugLn('[vdbg]   "%s", line:%d addr:%x enabled:%d',
      [bp.Source, bp.Line, bp.Address, integer(bp.Enabled)]);
  end;
end;

class function TVDbg.GetDbgApiClass: TVDbgApiClass;
begin
  {$ifdef windows}
  Result := TWinDbgApi;
  {$else}
     {$fatal 'not implemented'}
  {$endif}
end;

function TVDbg.GetSupportedCommands: TDBGCommands;
begin
  Result := [dcRun, dcPause, dcStop, dcAttach, dcDetach, dcBreak, dcEvaluate];
end;

function TVDbg.RequestCommand(
  const ACommand: TDBGCommand;
  const AParams: array of const): Boolean;
var
  EvalFlags: TDBGEvaluateFlags;
  ProcessId: integer;
begin
  DebugLn('[vdbg] now "%s", want "%s"', [DBGStateNames[State], DBGCommandNames[ACommand]]);

  case ACommand of
    dcRun, dcAttach:
      begin
        case State of
          dsStop:
            begin
              FDbgThread := nil;
              if ACommand = dcRun then
                begin
                  FDbgThread := TVDebuggerThread.CreateForNewProcess(self, FileName, Arguments);
                end
              else
                begin
                  if TryStrToInt(string(AParams[0].VAnsiString), ProcessId) then
                    FDbgThread := TVDebuggerThread.CreateForAttach(self, ProcessId);
                end;
              if Assigned(FDbgThread) then
              begin
                FDbgThread.Start;
                FDbgThread.FDbgStartupDone.WaitFor(INFINITE);
                Result := FDbgThread.FDebuggerInitialized;
                if Result then
                  SetState(dsRun);
                FDbgThread.FContinueEvent.SetEvent;
                Exit(True);
              end;
            end;
        dsPause:
          begin
            FDbgThread.FContinueEvent.SetEvent;
            Exit(True);
          end;
        end;
      end;
    dcDetach:
      begin
        FDbgThread.SetUserCommand(ucDetach);
        FDbgThread.FContinueEvent.SetEvent;
        Exit(True);
      end;
    dcStop:
      begin
        FDbgThread.SetUserCommand(ucTerminate);
        FDbgThread.FContinueEvent.SetEvent; // if now paused, it should wake debugger thread
        FDbgThread := nil;
        Exit(True);
      end;
    dcPause:
      begin
        // This should debug break debuggee process.
        FDbgThread.SetUserCommand(ucPause);
        Exit(True);
      end;
    dcEvaluate:
      begin
        // Just simulate.

        // [0] const AExpression: String
        // [1] AResult: ^String
        // [2] ATypeInfo: ^TDBGType
        // [3] Integer(EvalFlags): TDBGEvaluateFlags

        debugln('dcEvaluate; AExpression="%s"', [string(AParams[0].VAnsiString)]);

        EvalFlags := [];
        if high(AParams) >= 3 then
          EvalFlags := TDBGEvaluateFlags(AParams[3].VInteger);

        Result := DoEvaluate(String(AParams[0].VAnsiString),
          String(AParams[1].VPointer^), TDBGType(AParams[2].VPointer^),
          EvalFlags);

        Exit(Result);
      end;
  end;

  // Let all cases above to fallthrough here on failure.
  SetState(dsError);
  Exit(False);
end;

function TVDbg.DoEvaluate(const AExpression: String; var AResult: String; out
  ATypeInfo: TDBGType; EvalFlags: TDBGEvaluateFlags): Boolean;
begin
  AResult := AExpression + ' = 123';
  ATypeInfo := nil;
  Result := True;
end;

initialization

RegisterDebugger(TVDbg);

end.

